
; Test cases for threads and optimitsic concurrency

; The optimistic concurrency opcodes need some setting up by the
; runtime system before they can work (and be tested) properly


(define-test-suite thread-tests "thread-tests" (lambda ()
   
  ; checked-record-ref should work even without a current thread or proposal if logging is off
  ;
  ; record type: its enough if vm-eq? is true for two types, so we 
  ;              do not need a full record type system here
  (let ((record (make-record 3 (unspecific)))
        (type   #f)) 
    (record-set! record 0 type)
   
    (write-string "checked-record-ref, checked-record-set!")
    (newline) (newline)
    (checked-record-set! record type 2 #t)
    (checked-record-ref record type 2))
   
  ; test the thread opcodes and setup a valid thread for the optimistic concurrency tests
  ; A thread is a record as defined in rts/fluid.scm. Here we only need the proposal field
  ;
  (let ((thread (make-record 4 (unspecific))))
    (record-set! thread 0 #f)  ; record type
    (record-set! thread 1 '()) ; dynamic-env
    (record-set! thread 2 #f)  ; dynamic-point
    (record-set! thread 3 #f)  ; proposal
  
    (set-current-thread! thread)     
    (bool-test current-thread (eq? (current-thread) thread) "(current-thread)" #t))
          
  ; A proposal is a 4 entry vector. See make-proposal in rts/low.scm
  ;
  (let ((proposal (make-vector 4 (unspecific))))
    (vector-set! proposal 0 #f)     ; in-use?
    (vector-set! proposal 1 '#(#f)) ; d-log (empty)
    (vector-set! proposal 2 '#(#f)) ; b-log (empty)
    (vector-set! proposal 3 #f)     ; copy-list

    (set-current-proposal! proposal) ; this needs a valid current thread
    
    (bool-test current-proposal (eq? (current-proposal) proposal) "(current-proposal)" #t)
    (bool-test (eq? (vector-ref proposal 0) #t) "proposal in use?" #t))
          
  ; Its hard to test these properly, so just execute them and see if this causes any trouble
  ;
  (newline)
  
  (let ((pair (cons 1 2)))
    (write-string "stored-object-logging-ref, stored-object-set!")
    (newline)
    (provisional-car pair)
    (provisional-set-car! pair 3))    
    
  ; Again the record check, this time with logging
  ;
  (let ((record (make-record 3 (unspecific)))
        (type   #f)) 
    (record-set! record 0 type)
   
    (write-string "checked-record-ref, checked-record-set! (provisional)")
    (newline)
    (checked-record-set! record type 2 #t)
    (checked-record-ref record type 2)
    (provisional-checked-record-set! record type 2 #t)
    (provisional-checked-record-ref record type 2))
    
  (write-string "copy-bytes, attempt-copy-bytes")
  (newline)
  (copy-bytes! (string->low-string "abcdefgh") 0 (string->low-string "        ") 1 5) 
  (attempt-copy-bytes! (string->low-string "abcdefgh") 0 (string->low-string "        ") 1 5)
    
  (write-string "maybe-commit")
  (newline)
  (maybe-commit)
  
  (write-string "session-data, set-session-data!")
  (newline)
  (set-session-data! (session-data))
    
  (write-string "schedule-interrupt")
  (newline)
  (schedule-interrupt 0)
  
  ; Test the interrupt system.
  ; - this works only fully in the real VM
  ; - this requires a propery setup current thread, as it removes and restores the current proposal 
  ;
  (newline)
  (if (is-real-vm?)
    (thunk-test "interrupt-handling"
      (lambda ()  
        (let ((interrupted? #f))    
          (set-interrupt-handlers!
            (make-vector interrupt-count
              (lambda arguments
                (set! interrupted? #t))))      
          (set-enabled-interrupts! 
            (arithmetic-shift 1 (enum interrupt post-major-gc)))
          (collect) ; should cause the post-major-gc interrupt
          (poll)    ; need a poll, so the interrupt is handled here, and not later
          interrupted?))))
          
  ))